; Muster Text 1
(setf my-text
     (make-array 12 :adjustable t :initial-contents
                 '(("a" 0   100 0  20)
                   ("g" 200 100 0  20)
                   ("b" 120 220 0  20)
                   ("c" 240 340 0  70)
                   ("d" 0   100 30 50)
                   ("e" 120 220 30 50)
                   ("h" 100 340 30 10)
                   ("f" 240 340 30 10)
                   ("hoho" 0 100 60 80)
                   ("xline" 0 120 130 150)
                   ("xline 2" 0 140 160 180)
                   ("xline 3" 0 130 190 210) )))

; Muster Text 2
; 2 - Columns 1 Row Format

(setf my-text-two-column
     (make-array 28 :adjustable t :initial-contents
                 '(("i" 0 10 0 20)
                   ("have" 20 60 0  20)
                   ("a" 70 80 0 20)
                   ("little" 90 150 0 20)
                   ("dog." 0 30 30 50)
                   ("and" 41 70 30 50)
                   ("his" 80 110 30 50)
                   ("name" 120 160 30 50)
                   ("is" 0 30 60 80)
                   ("bingo." 40 100 60 80)

                   ("i" 200 210 0 20)
                   ("don't" 220 270 0 20)
                   ("have" 280 320 0 20)
                   ("any" 330 360 0 20)
                   ("funny" 200 250 30 50)
                   ("cat." 260 300 30 50)
                   ("So" 310 330 30 50)
                   ("i" 340 350 30 50)
                   ("am" 200 220 60 80)
                   ("alone." 230 290 60 80)

                   ("good" 0 40 140 160)
                   ("bye" 50 80 140 160)
                   ("teacher." 91 170 140 160)
                   ("here" 180 220 140 160)
                   ("is" 231 250 140 160)
                   ("your" 261 300 140 160)
                   ("song." 311 360 140 160)

                   ("erhan" 0 51 170 190)
                    )))


; Compare funktionen
; Die werden in den Sort- Methoden verwendet.

(defun compare-cluster (e1 e2)
 (and (eql (second e1) (second e2))
      (< (third e1) (third e2)) t))

(defun compare-mix (obj1 obj2)
  (if (> (length obj1) 5)
     (setf val1 (third obj1))
   (setf val1 (fourth obj1)))
 (if (> (length obj2) 5)
     (setf val2 (third obj2))
   (setf val2 (fourth obj2)))
 (and (eql (second obj1) (second obj2))
      (> val1 val2)))

(defun is-cluster (el)
 (and (listp el) (> (length el) 5) t))

(defun is-word (el)
 (and (listp el) (< (length el) 6) t))

(defun compare-func1 (e1 e2)
 (and (eql (fifth e1) (fifth e2))
      (< (second e1) (second e2)) t))

(defun compare-func2 (e1 e2)
 (and (eql (second e1) (second e2))
      (< (fifth e1) (fifth e2)) t))

(defun compare-func3 (e1 e2)
 (and (eql (third e1) (third e2))
      (< (fifth e1) (fifth e2)) t))


; Sortiert den Text nach gegebenen Sort- Funktionen
; Bubblesort

(defun sort-text (lst func-comp first-sort-func)
 ; sorts according-to-y-sorted-list with bubble sort.
 (let ((result (sort (copy-seq lst) #'< :key first-sort-func)))
     ; any other idea to reduce O(n^2) time complexity?
     ; binary search tree does give a better result? what about
     ; binary-search tree construction?
     (loop for i from (1- (length result)) downto 0 do
           (loop for j from 0 to i
                 when (funcall func-comp (aref result i) (aref result j))
                 do (rotatef (aref result i) (aref result j)) ))
    result))

; Sucht nach Clustern im Cluster- Array.

(defun find-cluster (cluster-arr x type)
 ; searchs for clusters with x coordinate on a x-line
 (and (arrayp cluster-arr)
      (> (array-total-size cluster-arr) 0)
      (let ((result nil) (arr-size (array-total-size cluster-arr)))
        (loop for i from 0 to (1- arr-size) do
              (and
                (eql (second (aref cluster-arr i)) x)
                (eql type (fifth (aref cluster-arr i)))
                (setf result (aref cluster-arr i)))) result)))

; Fügt er ein neues Element ins Array hinzu.

(defun append-to-cluster (cluster element)
 "appends a new element"
 (if (arrayp cluster)
     (progn
       (adjust-array cluster (1+ (array-total-size cluster)))
       (setf (aref cluster (1- (array-total-size cluster))) element))))

; Diese Funktion berechnet Cluster- Layout

(defun create-cluster-layout (txtarr)
 ; creates clustered- layout according to word postions.
 ; Note: cluster array could be considered as an binary search tree
 ; to get a better time complexity.
 (let* ((s (array-total-size txtarr))
        (source-toleft  (sort-text txtarr #'compare-func2 #'second))
        (source-toright (sort-text txtarr #'compare-func2 #'third ))
        (cluster-arr (make-array 0 :adjustable t)))
   ; (print source-toleft)
   ;; search for clusters
   (loop for i from 1 to (1- s) do
         (cond
          ;;; searching left-aligned.
          ((eql (second (aref source-toleft i)) (second (aref source-toleft (1- i))))
           (let*
                ((cluster-found (find-cluster cluster-arr (second(aref source-toleft (1- i))) :LEFT))
                (x-line  (second (aref source-toleft (1- i))))
                (y-end-prev (fifth (aref source-toleft (1- i))))
                (y-end-curr (fifth (aref source-toleft i)))
                (distance (sixth cluster-found)))
             ;;;; if no cluster found in cluster array, appends a newone.  ("name" x y0 y2 type word-distance)
             (if (null cluster-found)
                 (append-to-cluster cluster-arr (list "cluster" x-line y-end-prev y-end-curr :LEFT 0 :words nil))
                 ;;;;; word (y1 - y0) distance analyse
                 (if (eql distance 0)
                     (progn
                       (setf (fourth cluster-found) y-end-curr)
                       (setf (sixth cluster-found) (- y-end-curr y-end-prev)))
                       ; if word distance is as expected, then extend cluster
                   (if (eql distance (- y-end-curr (fourth cluster-found)))
                         (setf (fourth cluster-found) y-end-curr)
                         ; there is an another cluster in the same x-line
                         (append-to-cluster cluster-arr (list "cluster" x-line y-end-curr y-end-curr :LEFT 0 :words nil)))
                 ))))
          ; alignment right - clusters - noch nicht fertig
          ((eql (third  (aref source-toright i)) (third  (aref source-toright (1- i))))
           (let
               ((cluster-found (find-cluster cluster-arr (second(aref source-toright (1- i))) :RIGHT))
                (x-line (third (aref source-toright (1- i))))
                (y-start (fifth (aref source-toright (1- i))))
                (y-end (fifth (aref source-toright i))))
             (if (null cluster-found)
                 (progn
                   (adjust-array cluster-arr (1+ (array-total-size cluster-arr)))
                   (setf (aref cluster-arr (1- (array-total-size cluster-arr)))
                         (list "--- right cluster-" x-line y-start y-end :RIGHT)))
               (setf (fourth cluster-found) (fourth (aref source-toright i))))))))
  cluster-arr))


; Sucht nach Cluster - Boundry (auf der Linkenseite) im Cluster-Layout
; Array liegt als nächste zum Wort.

(defun find-left-most-cluster (word cluster-layout)
 "searchs for a cluster which lies on most- left to the word"
 (let ((x (second word)) (y (fifth word)) (result nil) (distance-list (list nil 10000)) (size (array-total-size cluster-layout)))
   (loop for i from 0 to (1- size) do
         (let* ((cluster (aref cluster-layout i)) (xline (second cluster)))
            (if (>= x xline)
             (progn
                    (setf dist (- x xline))
                    (and (>= x xline)
                         (eql (fifth cluster) :LEFT)
                         (>= y (third cluster))
                         (<= y (fourth  cluster))
                         (<  dist (second distance-list))
                         (progn
                           (setf (first  distance-list) cluster)
                           (setf (second distance-list) (- x xline))
                           (setf result cluster)
                           )))))) distance-list))


; Erzeugt einen formatierten Text  (Mit Spalten)

(defun create-formated-text(txt)
 (let* ((sorted-text (sort-text txt #'compare-func1 #'fifth))
        (cluster-layout (sort-text (create-cluster-layout txt) #'compare-cluster #'second))
        (size (array-total-size txt))
        (result (list)))
   ; iterate over words
   (loop for i from 0 to (1- size) do
         (setf word (aref sorted-text i))
         (setf cluster (first (find-left-most-cluster word cluster-layout)))
         (if (null cluster)
             (push word result)
           (progn
             (if (null (eighth cluster))
                 (setf (eighth cluster) (list word))
               ; (push word (eighth cluster))
               (setf (cdr (last (nth 7 cluster))) (list word))
               ))))
   (setf result-lst (append result (coerce cluster-layout 'list)))
   (sort-text (make-array (length result-lst) :initial-contents result-lst) #'compare-mix #'second)))

; Prints formatted text

(defun print-formatted-text(txt)
 (let ((size (array-total-size txt)))
   (loop for i from 0 to (1- size) do
       ;  (print (aref txt i))
         (if (is-word (aref txt i))
             (print (first (aref txt i)))
           (if (null (nth 7 (aref txt i)))
               nil
             (dolist (curr (nth 7 (aref txt i)))
               (print (first curr))
               ))))))


; Cluster-Layout
(print (create-cluster-layout my-text-two-column))
; 3 Cluster / Text
(print (create-formated-text my-text-two-column))
; Das Ergebnis
(print-formatted-text (create-formated-text my-text-two-column))

; END
